home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / alloc.c next >
Encoding:
C/C++ Source or Header  |  1987-06-04  |  18.0 KB  |  903 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     alloc.c
  9.     IMPLEMENTATION-DEPENDENT
  10. */
  11.  
  12. #include "include.h"
  13.  
  14.  
  15. object Vignore_maximum_pages;
  16.  
  17.  
  18. #ifdef AV
  19. #ifdef ATT3B2
  20. #define    page(p)        (((int)(char *)(p)-0x80800000)>>PAGEWIDTH)
  21. #define    pagetochar(x)    ((char *)(((x) << PAGEWIDTH) + 0x80800000))
  22. #else
  23. #define    page(p)        ((int)(char *)(p)>>PAGEWIDTH)
  24. #define    pagetochar(x)    ((char *)((x) << PAGEWIDTH))
  25. #endif
  26. #endif
  27.  
  28. #ifdef MV
  29.  
  30.  
  31. #endif
  32.  
  33.  
  34. int real_maxpage = MAXPAGE;
  35. int new_holepage;
  36.  
  37. #define    available_pages    \
  38.     (real_maxpage-page(heap_end)-new_holepage-2*nrbpage-real_maxpage/32)
  39.  
  40.  
  41. #ifdef UNIX
  42. extern char *sbrk();
  43. #endif
  44.  
  45. #ifdef BSD
  46. #include <sys/time.h>
  47. #include <sys/resource.h>
  48. struct rlimit data_rlimit;
  49. extern etext;
  50. #endif
  51.  
  52. char *
  53. alloc_page(n)
  54. int n;
  55. {
  56.     char *e;
  57.     int m;
  58. #ifdef AOSVS
  59.  
  60. #endif
  61.  
  62.     e = heap_end;
  63.     if (n >= 0) {
  64.         if (n >= holepage) {
  65.             holepage = new_holepage + n;
  66.             GBC(t_relocatable);
  67.         }
  68.         holepage -= n;
  69.         heap_end += PAGESIZE*n;
  70.         return(e);
  71.     }
  72.     n = -n;
  73.     m = (core_end - heap_end)/PAGESIZE;
  74.     if (n <= m)
  75.         return(e);
  76.  
  77. #ifdef BSD
  78.     if (core_end != sbrk(0))
  79.         error("Someone allocated my memory!");
  80.     if (core_end != sbrk(PAGESIZE*(n - m)))
  81.         error("Can't allocate.  Good-bye!");
  82. #endif
  83.  
  84. #ifdef ATT
  85.     if (PAGESIZE*(n - m) > pagetochar(MAXPAGE) - core_end)
  86.         error("Can't allocate.  Good-bye!");
  87. #endif
  88.  
  89. #ifdef E15
  90.     if (PAGESIZE*(n - m) > pagetochar(MAXPAGE) - core_end)
  91.         error("Can't allocate.  Good-bye!");
  92. #endif
  93.  
  94. #ifdef DGUX
  95.  
  96.  
  97.  
  98.  
  99. #endif
  100.  
  101. #ifdef AOSVS
  102.  
  103.  
  104. #endif
  105.  
  106.     core_end += PAGESIZE*(n - m);
  107.  
  108. #ifdef AOSVS
  109.  
  110.  
  111. #endif
  112.  
  113.     return(e);
  114. }
  115.  
  116. object
  117. alloc_object(t)
  118. enum type t;
  119. {
  120.     STATIC object obj;
  121.     STATIC struct typemanager *tm;
  122.     STATIC int i;
  123.     STATIC char *p;
  124.     STATIC object x, f;
  125.  
  126. ONCE_MORE:
  127.     tm = tm_of(t);
  128.  
  129.     if (interrupt_flag) {
  130.         interrupt_flag = FALSE;
  131. #ifdef UNIX
  132.         alarm(0);
  133. #endif
  134.         terminal_interrupt(TRUE);
  135.         goto ONCE_MORE;
  136.     }
  137.     obj = tm->tm_free;
  138.     if (obj == OBJNULL) {
  139.         if (tm->tm_npage >= tm->tm_maxpage)
  140.             goto CALL_GBC;
  141.         if (available_pages < 1) {
  142.             Vignore_maximum_pages->s.s_dbind = Cnil;
  143.             goto CALL_GBC;
  144.         }
  145.         p = alloc_page(1);
  146.         type_map[page(p)] = (char)tm->tm_type;
  147.         f = tm->tm_free;
  148.         for (i = tm->tm_nppage; i > 0; --i, p += tm->tm_size) {
  149.             x = (object)p;
  150.             ((struct freelist *)x)->t = (short)tm->tm_type;
  151.             ((struct freelist *)x)->m = FREE;
  152.             ((struct freelist *)x)->f_link = f;
  153.             f = x;
  154.         }
  155.         obj = tm->tm_free = f;
  156.         tm->tm_nfree += tm->tm_nppage;
  157.         tm->tm_npage++;
  158.         if (tm->tm_npage >= tm->tm_maxpage)
  159.             goto CALL_GBC;
  160.     }
  161.     tm->tm_free = ((struct freelist *)obj)->f_link;
  162.     --(tm->tm_nfree);
  163.     (tm->tm_nused)++;
  164.     obj->d.t = (short)t;
  165.     obj->d.m = FALSE;
  166.     return(obj);
  167.  
  168. CALL_GBC:
  169.     GBC(tm->tm_type);
  170.     if (tm->tm_nfree == 0 ||
  171.         (float)tm->tm_nfree * 10.0 < (float)tm->tm_nused)
  172.         goto EXHAUSTED;
  173.     goto ONCE_MORE;
  174.  
  175. EXHAUSTED:
  176.     if (symbol_value(Vignore_maximum_pages) != Cnil) {
  177.         if (tm->tm_maxpage/2 <= 0)
  178.             tm->tm_maxpage += 1;
  179.         else
  180.             tm->tm_maxpage += tm->tm_maxpage/2;
  181.         goto ONCE_MORE;
  182.     }
  183.     GBC_enable = FALSE;
  184.     vs_push(make_simple_string(tm_table[(int)t].tm_name+1));
  185.     vs_push(make_fixnum(tm->tm_npage));
  186.     GBC_enable = TRUE;
  187.     CEerror("The storage for ~A is exhausted.~%\
  188. Currently, ~D pages are allocated.~%\
  189. Use ALLOCATE to expand the space.",
  190.         "Continues execution.",
  191.         2, vs_top[-2], vs_top[-1]);
  192.     vs_pop;
  193.     vs_pop;
  194.     goto ONCE_MORE;
  195. }
  196.  
  197. object
  198. make_cons(a, d)
  199. object a, d;
  200. {
  201.     STATIC object obj;
  202.     STATIC int i;
  203.     STATIC char *p;
  204.     STATIC object x, f;
  205.  
  206. #define    tm    (&tm_table[(int)t_cons])
  207.  
  208. ONCE_MORE:
  209.     if (interrupt_flag) {
  210.         interrupt_flag = FALSE;
  211. #ifdef UNIX
  212.         alarm(0);
  213. #endif
  214.         terminal_interrupt(TRUE);
  215.         goto ONCE_MORE;
  216.     }
  217.     obj = tm->tm_free;
  218.     if (obj == OBJNULL) {
  219.         if (tm->tm_npage >= tm->tm_maxpage)
  220.             goto CALL_GBC;
  221.         if (available_pages < 1) {
  222.             Vignore_maximum_pages->s.s_dbind = Cnil;
  223.             goto CALL_GBC;
  224.         }
  225.         p = alloc_page(1);
  226.         type_map[page(p)] = (char)t_cons;
  227.         f = tm->tm_free;
  228.         for (i = tm->tm_nppage; i > 0; --i, p += tm->tm_size) {
  229.             x = (object)p;
  230.             ((struct freelist *)x)->t = (short)t_cons;
  231.             ((struct freelist *)x)->m = FREE;
  232.             ((struct freelist *)x)->f_link = f;
  233.             f = x;
  234.         }
  235.         obj = tm->tm_free = f;
  236.         tm->tm_nfree += tm->tm_nppage;
  237.         tm->tm_npage++;
  238.         if (tm->tm_npage >= tm->tm_maxpage)
  239.             goto CALL_GBC;
  240.     }
  241.     tm->tm_free = ((struct freelist *)obj)->f_link;
  242.     --(tm->tm_nfree);
  243.     (tm->tm_nused)++;
  244.     obj->c.t = (short)t_cons;
  245.     obj->c.m = FALSE;
  246.     obj->c.c_car = a;
  247.     obj->c.c_cdr = d;
  248.     return(obj);
  249.  
  250. CALL_GBC:
  251.     GBC(t_cons);
  252.     if (tm->tm_nfree == 0 ||
  253.         (float)tm->tm_nfree * 10.0 < (float)tm->tm_nused)
  254.         goto EXHAUSTED;
  255.     goto ONCE_MORE;
  256.  
  257. EXHAUSTED:
  258.     if (symbol_value(Vignore_maximum_pages) != Cnil) {
  259.         if (tm->tm_maxpage/2 <= 0)
  260.             tm->tm_maxpage += 1;
  261.         else
  262.             tm->tm_maxpage += tm->tm_maxpage/2;
  263.         goto ONCE_MORE;
  264.     }
  265.     GBC_enable = FALSE;
  266.     vs_push(make_fixnum(tm->tm_npage));
  267.     GBC_enable = TRUE;
  268.     CEerror("The storage for CONS is exhausted.~%\
  269. Currently, ~D pages are allocated.~%\
  270. Use ALLOCATE to expand the space.",
  271.         "Continues execution.",
  272.         1, vs_top[-1]);
  273.     vs_pop;
  274.     goto ONCE_MORE;
  275. #undef    tm
  276. }
  277.  
  278. #define    round_up(n)    (((n) + 03) & ~03)
  279.  
  280. char *
  281. alloc_contblock(n)
  282. int n;
  283. {
  284.     STATIC char *p;
  285.     STATIC struct contblock **cbpp;
  286.     STATIC int i;
  287.     STATIC int m;
  288.     STATIC bool g;
  289.     bool gg;
  290.  
  291. /*
  292.     printf("allocating %d-byte contiguous block...\n", n);
  293. */
  294.  
  295.     g = FALSE;
  296.     n = round_up(n);
  297.  
  298. ONCE_MORE:
  299.     if (interrupt_flag) {
  300.         interrupt_flag = FALSE;
  301.         gg = g;
  302.         terminal_interrupt(TRUE);
  303.         g = gg;
  304.         goto ONCE_MORE;
  305.     }
  306.     for(cbpp= &cb_pointer; (*cbpp)!=NULL; cbpp= &(*cbpp)->cb_link)
  307.         if ((*cbpp)->cb_size >= n) {
  308.             p = (char *)(*cbpp);
  309.             i = (*cbpp)->cb_size - n;
  310.             *cbpp = (*cbpp)->cb_link;
  311.             --ncb;
  312.             insert_contblock(p+n, i);
  313.             return(p);
  314.         }
  315.     m = (n + PAGESIZE - 1)/PAGESIZE;
  316.     if (ncbpage + m > maxcbpage || available_pages < m) {
  317.         if (available_pages < m)
  318.             Vignore_maximum_pages->s.s_dbind = Cnil;
  319.         if (!g) {
  320.             GBC(t_contiguous);
  321.             g = TRUE;
  322.             goto ONCE_MORE;
  323.         }
  324.         if (symbol_value(Vignore_maximum_pages) != Cnil) {
  325.             if (maxcbpage/2 <= 0)
  326.                 maxcbpage += 1;
  327.             else
  328.                 maxcbpage += maxcbpage/2;
  329.             g = FALSE;
  330.             goto ONCE_MORE;
  331.         }
  332.         vs_push(make_fixnum(ncbpage));
  333.         CEerror("Contiguous blocks exhausted.~%\
  334. Currently, ~D pages are allocated.~%\
  335. Use ALLOCATE-CONTIGUOUS-PAGES to expand the space.",
  336.             "Continues execution.", 1, vs_head);
  337.         vs_pop;
  338.         g = FALSE;
  339.         goto ONCE_MORE;
  340.     }
  341.  
  342.     p = alloc_page(m);
  343.  
  344.     for (i = 0;  i < m;  i++)
  345.         type_map[page(p) + i] = (char)t_contiguous;
  346.     ncbpage += m;
  347.     insert_contblock(p+n, PAGESIZE*m - n);
  348.     return(p);
  349. }
  350.  
  351. insert_contblock(p, s)
  352. char *p;
  353. int s;
  354. {
  355.     struct contblock **cbpp, *cbp;
  356.  
  357.     if (s < CBMINSIZE)
  358.         return;
  359.     ncb++;
  360.     cbp = (struct contblock *)p;
  361.     cbp->cb_size = s;
  362.     for (cbpp = &cb_pointer;  *cbpp;  cbpp = &((*cbpp)->cb_link))
  363.         if ((*cbpp)->cb_size >= s) {
  364.             cbp->cb_link = *cbpp;
  365.             *cbpp = cbp;
  366.             return;
  367.         }
  368.     cbp->cb_link = NULL;
  369.     *cbpp = cbp;
  370. }
  371.  
  372. char *
  373. alloc_relblock(n)
  374. int n;
  375. {
  376.     STATIC char *p;
  377.     STATIC bool g;
  378.     bool gg;
  379.     int i;
  380.  
  381. /*
  382.     printf("allocating %d-byte relocatable block...\n", n);
  383. */
  384.  
  385.     g = FALSE;
  386.     n = round_up(n);
  387.  
  388. ONCE_MORE:
  389.     if (interrupt_flag) {
  390.         interrupt_flag = FALSE;
  391.         gg = g;
  392.         terminal_interrupt(TRUE);
  393.         g = gg;
  394.         goto ONCE_MORE;
  395.     }
  396.     if (rb_limit - rb_pointer < n) {
  397.         if (!g) {
  398.             GBC(t_relocatable);
  399.             g = TRUE;
  400.             if ((float)(rb_limit - rb_pointer) * 10.0 <
  401.                 (float)(rb_limit - rb_start))
  402.                 ;
  403.             else
  404.                 goto ONCE_MORE;
  405.         }
  406.         if (symbol_value(Vignore_maximum_pages) != Cnil) {
  407.             if (nrbpage/2 <= 0)
  408.                 i = 1;
  409.             else
  410.                 i = nrbpage/2;
  411.             nrbpage += i;
  412.             if (available_pages < 0)
  413.                 nrbpage -= i;
  414.             else {
  415.                 rb_end = rb_start + PAGESIZE*nrbpage;
  416.                 rb_limit = rb_end - 2*RB_GETA;
  417.                 alloc_page(-(holepage + nrbpage));
  418.                 g = FALSE;
  419.                 goto ONCE_MORE;
  420.             }
  421.         }
  422.         if (rb_limit > rb_end - 2*RB_GETA)
  423.             error("relocatable blocks exhausted");
  424.         rb_limit += RB_GETA;
  425.         vs_push(make_fixnum(nrbpage));
  426.         CEerror("Relocatable blocks exhausted.~%\
  427. Currently, ~D pages are allocated.~%\
  428. Use ALLOCATE-RELOCATABLE-PAGES to expand the space.",
  429.             "Continues execution.", 1, vs_head);
  430.         vs_pop;
  431.         g = FALSE;
  432.         goto ONCE_MORE;
  433.     }
  434.     p = rb_pointer;
  435.     rb_pointer += n;
  436.     return(p);
  437. }
  438.  
  439. init_tm(t, name, elsize, maxpage)
  440. enum type t;
  441. char name[];
  442. int elsize, maxpage;
  443. {
  444.     int i, j;
  445.  
  446.     tm_table[(int)t].tm_name = name;
  447.     for (j = -1, i = 0;  i < (int)t_end;  i++)
  448.         if (tm_table[i].tm_size != 0 &&
  449.             tm_table[i].tm_size >= elsize &&
  450.             (j < 0 || tm_table[j].tm_size > tm_table[i].tm_size))
  451.             j = i;
  452.     if (j >= 0) {
  453.         tm_table[(int)t].tm_type = (enum type)j;
  454.         tm_table[j].tm_maxpage += maxpage;
  455.         return;
  456.     }
  457.     tm_table[(int)t].tm_type = t;
  458.     tm_table[(int)t].tm_size = round_up(elsize);
  459.     tm_table[(int)t].tm_nppage = PAGESIZE/round_up(elsize);
  460.     tm_table[(int)t].tm_free = OBJNULL;
  461.     tm_table[(int)t].tm_nfree = 0;
  462.     tm_table[(int)t].tm_nused = 0;
  463.     tm_table[(int)t].tm_npage = 0;
  464.     tm_table[(int)t].tm_maxpage = maxpage;
  465.     tm_table[(int)t].tm_gbccount = 0;
  466. }
  467.  
  468. set_maxpage()
  469. {
  470. #ifdef BSD
  471.     getrlimit(RLIMIT_DATA, &data_rlimit);
  472.     real_maxpage = ((int)&etext + data_rlimit.rlim_cur)/PAGESIZE;
  473.     if (real_maxpage > MAXPAGE)
  474.         real_maxpage = MAXPAGE;
  475. #endif
  476.  
  477. #ifdef ATT
  478.     real_maxpage = MAXPAGE;
  479. #endif
  480.  
  481. #ifdef E15
  482.     real_maxpage = MAXPAGE;
  483. #endif
  484.  
  485. #ifdef DGUX
  486.  
  487.  
  488.  
  489. #endif
  490.  
  491. #ifdef AOSVS
  492.  
  493. #endif
  494. }
  495.  
  496. init_alloc()
  497. {
  498.     int i, j;
  499.     struct typemanager *tm;
  500.     char *p, *q;
  501.     enum type t;
  502.     int c;
  503. #ifdef AOSVS
  504.  
  505. #endif
  506.  
  507.     holepage = INIT_HOLEPAGE;
  508.     new_holepage = HOLEPAGE;
  509.     nrbpage = INIT_NRBPAGE;
  510.  
  511.     set_maxpage();
  512.  
  513. #ifdef UNIX
  514.     heap_end = sbrk(0);
  515.     if (i = ((int)heap_end & (PAGESIZE - 1)))
  516.         sbrk(PAGESIZE - i);
  517.     heap_end = core_end = sbrk(0);
  518. #endif
  519.  
  520. #ifdef ATT
  521.     if (brk(pagetochar(MAXPAGE)) < 0)
  522.         error("Can't allocate.  Good-bye!.");
  523. #endif
  524.  
  525. #ifdef E15
  526.     if (brk(pagetochar(MAXPAGE)) < 0)
  527.         error("Can't allocate.  Good-bye!.");
  528. #endif
  529.  
  530. #ifdef AOSVS
  531.  
  532.  
  533. #endif
  534.  
  535.     alloc_page(-(holepage + nrbpage));
  536.     rb_start = rb_pointer = heap_end + PAGESIZE*holepage;
  537.     rb_end = rb_start + PAGESIZE*nrbpage;
  538.     rb_limit = rb_end - 2*RB_GETA;
  539.  
  540.     for (i = 0;  i < MAXPAGE;  i++)
  541.         type_map[i] = (char)t_other;
  542.  
  543.     init_tm(t_fixnum, "Nfixnum",
  544.         sizeof(struct fixnum_struct), 32);
  545.     init_tm(t_cons, ".cons", sizeof(struct cons), 384);
  546.     init_tm(t_structure, "Sstructure", sizeof(struct structure), 32);
  547.     init_tm(t_string, "\"string", sizeof(struct string), 64);
  548.     init_tm(t_array, "aarray", sizeof(struct array), 64);
  549.     init_tm(t_symbol, "|symbol", sizeof(struct symbol), 64);
  550.  
  551.     init_tm(t_bignum, "Bbignum", sizeof(struct bignum), 16);
  552.     init_tm(t_ratio, "Rratio", sizeof(struct ratio), 1);
  553.     init_tm(t_shortfloat, "Fshort-float",
  554.         sizeof(struct shortfloat_struct), 1);
  555.     init_tm(t_longfloat, "Llong-float",
  556.         sizeof(struct longfloat_struct), 1);
  557.     init_tm(t_complex, "Ccomplex", sizeof(struct complex), 1);
  558.     init_tm(t_character,"#character",sizeof(struct character),1);
  559.     init_tm(t_package, ":package", sizeof(struct package), 1);
  560.     init_tm(t_hashtable, "hhash-table", sizeof(struct hashtable), 1);
  561.     init_tm(t_vector, "vvector", sizeof(struct vector), 2);
  562.     init_tm(t_bitvector, "bbit-vector", sizeof(struct bitvector), 1);
  563.     init_tm(t_stream, "sstream", sizeof(struct stream), 1);
  564.     init_tm(t_random, "$random-state", sizeof(struct random), 1);
  565.     init_tm(t_readtable, "rreadtable", sizeof(struct readtable), 1);
  566.     init_tm(t_pathname, "ppathname", sizeof(struct pathname), 1);
  567.     init_tm(t_cfun, "fcfun", sizeof(struct cfun), 32);
  568.     init_tm(t_cclosure, "ccclosure", sizeof(struct cclosure), 1);
  569.     init_tm(t_spice, "!spice", sizeof(struct spice), 16);
  570.  
  571.     ncb = 0;
  572.     ncbpage = 0;
  573.     maxcbpage = 512;
  574. }
  575.  
  576.  
  577. cant_get_a_type()
  578. {
  579.     FEerror("Can't get a type.", 0);
  580. }
  581.  
  582. siLalloc()
  583. {
  584.     struct typemanager *tm;
  585.     int c, i;
  586.     char *p, *pp;
  587.     object f, x;
  588.  
  589.     if (vs_top - vs_base < 2)
  590.         too_few_arguments();
  591.     if (vs_top - vs_base > 3)
  592.         too_many_arguments();
  593.     vs_base[0] = coerce_to_string(vs_base[0]);
  594.     if (type_of(vs_base[1]) != t_fixnum ||
  595.         (i = fix(vs_base[1])) < 0)
  596.         FEerror("~A is not a non-negative fixnum.", 1, vs_base[1]);
  597.     if (vs_base[0]->st.st_fillp == 0)
  598.         cant_get_a_type();
  599.     c = vs_base[0]->st.st_self[0];
  600.     for (tm = &tm_table[(int)t_start];
  601.          tm < &tm_table[(int)t_end];
  602.          tm++)
  603.         if (c == tm->tm_name[0]) {
  604.             tm = &tm_table[(int)tm->tm_type];
  605.             if (tm->tm_npage > i) {
  606.                 vs_push(make_simple_string(tm->tm_name+1));
  607.                 vs_push(make_fixnum(tm->tm_npage));
  608.     FEerror("Can't set the limit for ~A to ~D pages,~%\
  609. since ~D pages are already allocated.", 3, vs_top[-2],vs_base[1],vs_top[-1]);
  610.             }
  611.             tm->tm_maxpage = i;
  612.             if (vs_top - vs_base == 3 && vs_base[2] != Cnil &&
  613.                 tm->tm_maxpage > tm->tm_npage)
  614.                 goto ALLOCATE;
  615.             vs_top = vs_base;
  616.             vs_push(Ct);
  617.             return;
  618.         }
  619.     cant_get_a_type();
  620.  
  621. ALLOCATE:
  622.     if (available_pages < tm->tm_maxpage - tm->tm_npage ||
  623.         (pp = alloc_page(tm->tm_maxpage - tm->tm_npage)) == NULL) {
  624.     vs_push(make_simple_string(tm->tm_name+1));
  625.     FEerror("Can't allocate ~D pages for ~A.", 2, vs_base[1], vs_top[-1]);
  626.     }
  627.     for (;  tm->tm_npage < tm->tm_maxpage;  pp += PAGESIZE) {
  628.         p = pp;
  629.         type_map[page(p)] = (char)tm->tm_type;
  630.         f = tm->tm_free;
  631.         for (i = tm->tm_nppage; i > 0; --i, p += tm->tm_size) {
  632.             x = (object)p;
  633.             ((struct freelist *)x)->t = (short)tm->tm_type;
  634.             ((struct freelist *)x)->m = FREE;
  635.             ((struct freelist *)x)->f_link = f;
  636.             f = x;
  637.         }
  638.         tm->tm_free = f;
  639.         tm->tm_nfree += tm->tm_nppage;
  640.         tm->tm_npage++;
  641.     }
  642.     vs_top = vs_base;
  643.     vs_push(Ct);
  644. }
  645.  
  646. siLnpage()
  647. {
  648.     struct typemanager *tm;
  649.     int c;
  650.  
  651.     check_arg(1);
  652.     vs_base[0] = coerce_to_string(vs_base[0]);
  653.     if (vs_base[0]->st.st_fillp == 0)
  654.         cant_get_a_type();
  655.     c = vs_base[0]->st.st_self[0];
  656.     for (tm = &tm_table[(int)t_start];
  657.          tm < &tm_table[(int)t_end];
  658.          tm++)
  659.         if (c == tm->tm_name[0]) {
  660.             tm = &tm_table[(int)tm->tm_type];
  661.             vs_base[0] = make_fixnum(tm->tm_npage);
  662.             return;
  663.         }
  664.     cant_get_a_type();
  665. }
  666.  
  667. siLmaxpage()
  668. {
  669.     struct typemanager *tm;
  670.     int c;
  671.  
  672.     check_arg(1);
  673.     vs_base[0] = coerce_to_string(vs_base[0]);
  674.     if (vs_base[0]->st.st_fillp == 0)
  675.         cant_get_a_type();
  676.     c = vs_base[0]->st.st_self[0];
  677.     for (tm = &tm_table[(int)t_start];
  678.          tm < &tm_table[(int)t_end];
  679.          tm++)
  680.         if (c == tm->tm_name[0]) {
  681.             tm = &tm_table[(int)tm->tm_type];
  682.             vs_base[0] = make_fixnum(tm->tm_maxpage);
  683.             return;
  684.         }
  685.     cant_get_a_type();
  686. }
  687.  
  688. siLalloc_contpage()
  689. {
  690.     int i, m;
  691.     char *p;
  692.  
  693.     if (vs_top - vs_base < 1)
  694.         too_few_arguments();
  695.     if (vs_top - vs_base > 2)
  696.         too_many_arguments();
  697.     if (type_of(vs_base[0]) != t_fixnum ||
  698.         (i = fix(vs_base[0])) < 0)
  699.         FEerror("~A is not a non-negative fixnum.", 1, vs_base[0]);
  700.     if (ncbpage > i) {
  701.         vs_push(make_fixnum(ncbpage));
  702.         FEerror("Can't set the limit for contiguous blocks to ~D,~%\
  703. since ~D pages are already allocated.",
  704.             2, vs_base[0], vs_head);
  705.     }
  706.     maxcbpage = i;
  707.     if (vs_top - vs_base < 2 || vs_base[1] == Cnil) {
  708.         vs_top = vs_base;
  709.         vs_push(Ct);
  710.         return;
  711.     }
  712.     m = maxcbpage - ncbpage;
  713.     if (available_pages < m || (p = alloc_page(m)) == NULL)
  714.         FEerror("Can't allocate ~D pages for contiguous blocks.",
  715.             1, vs_base[0]);
  716.     for (i = 0;  i < m;  i++)
  717.         type_map[page(p + PAGESIZE*i)] = (char)t_contiguous;
  718.     ncbpage += m;
  719.     insert_contblock(p, PAGESIZE*m);
  720.     vs_top = vs_base;
  721.     vs_push(Ct);
  722. }
  723.  
  724. siLncbpage()
  725. {
  726.     check_arg(0);
  727.     vs_push(make_fixnum(ncbpage));
  728. }
  729.  
  730. siLmaxcbpage()
  731. {
  732.     check_arg(0);
  733.     vs_push(make_fixnum(maxcbpage));
  734. }
  735.  
  736. siLalloc_relpage()
  737. {
  738.     int i;
  739.     char *p;
  740.  
  741.     if (vs_top - vs_base < 1)
  742.         too_few_arguments();
  743.     if (vs_top - vs_base > 2)
  744.         too_many_arguments();
  745.     if (type_of(vs_base[0]) != t_fixnum ||
  746.         (i = fix(vs_base[0])) < 0)
  747.         FEerror("~A is not a non-negative fixnum.", 1, vs_base[0]);
  748.     if (nrbpage > i && rb_pointer >= rb_start + PAGESIZE*i - 2*RB_GETA
  749.      || 2*i > real_maxpage-page(heap_end)-new_holepage-real_maxpage/32)
  750.         FEerror("Can't set the limit for relocatable blocks to ~D.",
  751.             1, vs_base[0]);
  752.     nrbpage = i;
  753.     rb_end = rb_start + PAGESIZE*i;
  754.     rb_limit = rb_end - 2*RB_GETA;
  755.     alloc_page(-(holepage + nrbpage));
  756.     vs_top = vs_base;
  757.     vs_push(Ct);
  758. }
  759.  
  760. siLnrbpage()
  761. {
  762.     check_arg(0);
  763.     vs_push(make_fixnum(nrbpage));
  764. }
  765.  
  766. siLget_hole_size()
  767. {
  768.     check_arg(0);
  769.     vs_push(make_fixnum(new_holepage));
  770. }
  771.  
  772. siLset_hole_size()
  773. {
  774.     int i;
  775.  
  776.     check_arg(1);
  777.     i = fixint(vs_base[0]);
  778.     if (i < 1 ||
  779.         i > real_maxpage - page(heap_end) - 2*nrbpage - real_maxpage/32)
  780.         FEerror("Illegal value for the hole size.", 0);
  781.     new_holepage = i;
  782. }
  783.  
  784. init_alloc_function()
  785. {
  786.     make_si_function("ALLOC", siLalloc);
  787.     make_si_function("NPAGE", siLnpage);
  788.     make_si_function("MAXPAGE", siLmaxpage);
  789.     make_si_function("ALLOC-CONTPAGE", siLalloc_contpage);
  790.     make_si_function("NCBPAGE", siLncbpage);
  791.     make_si_function("MAXCBPAGE", siLmaxcbpage);
  792.     make_si_function("ALLOC-RELPAGE", siLalloc_relpage);
  793.     make_si_function("NRBPAGE", siLnrbpage);
  794.     make_si_function("GET-HOLE-SIZE", siLget_hole_size);
  795.     make_si_function("SET-HOLE-SIZE", siLset_hole_size);
  796.  
  797.     Vignore_maximum_pages
  798.     = make_special("*IGNORE-MAXIMUM-PAGES*", Ct);
  799.  
  800. #ifdef UNIX
  801. #ifndef DGUX
  802.     {
  803.         extern object malloc_list;
  804.  
  805.         malloc_list = Cnil;
  806.         enter_mark_origin(&malloc_list);
  807.     }
  808. #endif
  809. #endif
  810. }
  811.  
  812. #ifdef UNIX
  813. #ifndef DGUX
  814.  
  815. /*
  816.     UNIX malloc simulator.
  817.  
  818.     Used by
  819.         getwd, popen, etc.
  820. */
  821.  
  822. object malloc_list;
  823.  
  824. char *
  825. malloc(size)
  826. int size;
  827. {
  828.     object x;
  829.  
  830.     x = alloc_simple_string(size);
  831.     vs_push(x);
  832.     x->st.st_self = alloc_contblock(size);
  833.     malloc_list = make_cons(x, malloc_list);
  834.     vs_pop;
  835.     return(x->st.st_self);
  836. }
  837.  
  838. free(ptr)
  839. char *ptr;
  840. {
  841.     object *p;
  842.  
  843.     for (p = &malloc_list;  !endp(*p);  p = &((*p)->c.c_cdr))
  844.         if ((*p)->c.c_car->st.st_self == ptr) {
  845.             insert_contblock((*p)->c.c_car->st.st_self,
  846.                      (*p)->c.c_car->st.st_dim);
  847.             (*p)->c.c_car->st.st_self = NULL;
  848.             *p = (*p)->c.c_cdr;
  849.             return;
  850.         }
  851.     FEerror("free(3) error.", 0);
  852. }
  853.  
  854. char *
  855. realloc(ptr, size)
  856. char *ptr;
  857. int size;
  858. {
  859.     object x;
  860.     int i, j;
  861.  
  862.     for (x = malloc_list;  !endp(x);  x = x->c.c_cdr)
  863.         if (x->c.c_car->st.st_self == ptr) {
  864.             x = x->c.c_car;
  865.             if (x->st.st_dim >= size) {
  866.                 x->st.st_fillp = size;
  867.                 return(ptr);
  868.             } else {
  869.                 j = x->st.st_dim;
  870.                 x->st.st_self = alloc_contblock(size);
  871.                 x->st.st_fillp = x->st.st_dim = size;
  872.                 for (i = 0;  i < size;  i++)
  873.                     x->st.st_self[i] = ptr[i];
  874.                 insert_contblock(ptr, j);
  875.                 return(x->st.st_self);
  876.             }
  877.         }
  878.     FEerror("realloc(3) error.", 0);
  879. }
  880.  
  881. char *
  882. calloc(nelem, elsize)
  883. int nelem, elsize;
  884. {
  885.     char *ptr;
  886.     int i;
  887.  
  888.     ptr = malloc(i = nelem*elsize);
  889.     while (--i >= 0)
  890.         ptr[i] = 0;
  891.     return(ptr);
  892. }
  893.  
  894. cfree(ptr)
  895. char *ptr;
  896. {
  897.     free(ptr);
  898. }
  899.  
  900. #endif
  901. #endif
  902.  
  903.